home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1994 #2 / Monster Media No. 2 (Monster Media)(1994).ISO / prog_pas / ddplus63.zip / DDPLUS.PAS < prev    next >
Pascal/Delphi Source File  |  1994-07-09  |  30KB  |  1,149 lines
  1.  
  2. unit DDPlus;
  3. {$V-,F+}
  4.  
  5. interface
  6. uses dos, crt, comio, ddscott, ddansi2, ddovr, ddovr2;
  7. type
  8.  CharOriginType=(localchar,remotechar);
  9.  strptr=^string;
  10. const
  11.  version= 'Version 6.3; 07-09-94';
  12.  
  13. { Changes: blame on Steve Lorenz                                             }
  14. { This program is a 'stripped' down version doordiver.  Most sysop things    }
  15. { and Term program flags have been eliminated. What has been enhanced are    }
  16. { the communication routines.                                                }
  17. { Documentation  What Documentation?  See Doordrivers docs or read the code. }
  18. { Here is a list of most of the additions:                                   }
  19. { Ansi color efficiency checking                                             }
  20. { IRQs 0-15 support                                                          }
  21. { Selectable Port Addresses                                                  }
  22. { DESQview support                                                           }
  23. { PCBoard 15 support                                                         }
  24. { Rip Detect or found on WC3.9+ or PCB15 dropfiles                           }
  25. { TriBBS dropfile support  (untested)                                        }
  26. { RBBS vs Super BBS Dorinfo types supported                                  }
  27. { CTS/RTS flow checking    (Not well documented but it works)                }
  28. { carrier detect on output                                                   }
  29. { lock baud and comm baud rates to 115,200                                   }
  30. { Windows,WindowsNT,OS/2,DOS 5.0+ time slice releasing.                      }
  31. { A Dos,Win, DV pause is taken after so many read cycles in read loop        }
  32. { fossil support to 38,400 using normal fossil calls.                        }
  33. { fossil support to 115,200 using X00 extended fossil calls.                 }
  34. { 6.1                                                                        }
  35. { Added mixture of tasker pause and loop cycles in Ripdetect and read char   }
  36. { to give a smoother response.                                               }
  37. { 6.2                                                                        }
  38. { Missed Done Routine in 6.1  - now doesn't close if local or X00extOK       }
  39. { but buffered flag is set to true.                                          }
  40. { There was a file being written to when door timed out.  Some OS2 systems   }
  41. { complained of endless pages being written to their disk.  I'm taking this  }
  42. { out this version.  So if you have a use for it save it and put it back in. }
  43. {6.3                                                                         }
  44. { Wrong-O I guess a lot of you are using this file so I'm putting it back in.}
  45. { I guess only my versions will leave it out.                                }
  46. { Added /C to specify comport on command line.  Dropfile comport number will }
  47. { override this option.                                                      }
  48.  
  49.  progname: string[60] = 'Systems Door Game';
  50.  graphics_codes: array[1..4] of string[4] = ('','.ASC','.ANS','.MUS');
  51.  ack=#6;
  52.  nak=#21;
  53.  sot=#1;
  54. var
  55.  mintime: byte;                     {Minimum time left before user kicked off}
  56.  notime: string;                    {Out of time filename                    }
  57.  macro,macro_str: string;           {Used in the macro routines              }
  58.  node_num: byte;                    {Node number                             }
  59.  time_credit: integer;              {Time credit +/- (arrow keys)            }
  60.  CharOrigin: CharOrigInType;        {Where character came from               }
  61.  fouled_up: char;                   {Internal use                            }
  62.  localcol: boolean;                 {From .CTL file: Local color enabled     }
  63.  ansion: boolean;                   {Process ANSI locally                    }
  64.  time_check: boolean;               {Check time left - halt if < mintime     }
  65.  curlinenum: integer;               {current line num - used by <more>       }
  66.  stacked: string;                   {used internally - stacked commands      }
  67.  current_foreground: byte;          {current foreground color                }
  68.  current_background: byte;          {current background color                }
  69.  color_chg: boolean;                {send ANSI color change sequences?       }
  70.  default_fore: byte;                {default foreground color                }
  71.  default_back: byte;                {default background color                }
  72.  cdropped: boolean;                 {carrier dropped?                        }
  73.  bbs_time_left: integer;            {from DROP FILE: time left               }
  74.  com_port: byte;                    {from DROP FILE: com port                }
  75.  bbs_software: byte;                {from .CTL file: bbs type                }
  76.  baud_rate: longint;                {from DROP FILE: baud rate               }
  77.  statfore,statback: byte;           {status line foreground                  }
  78.  statline: boolean;                 {status line background                  }
  79.  graphics: byte;                    {from DROP FILE: graphics code           }
  80.  local: boolean;                    {from DROP FILE: local mode              }
  81.  user_number: word;           {from DROP FILE: user's access level     }
  82.  user_first_name: string[30];       {from DROP FILE: user's first name       }
  83.  user_last_name: string[30];        {from DROP FILE: user's last name        }
  84.  sysop_first_name: string[30];      {from .CTL file: sysop's first name      }
  85.  sysop_last_name: string[30];       {from .CTL file: sysop's last name       }
  86.  board_name: string[70];            {from .CTL file: board name              }
  87.  Pause_Code : string;
  88.  st_hr, st_mn, st_sc: word;         {used by timer calculations              }
  89.  color1: boolean;                   {from .CTL file: color1 mode             }
  90.  ESMOK : boolean;                   {/ESM use esm memory                     }
  91.  stackon: boolean;                  {process stacked commands?               }
  92.  badchar: string;                   {internal use                            }
  93.  fossilIO: boolean;                 {from .CTL file: fossil I/O used         }
  94.  maxtime: word;                     {from .CTL file: maximum time in door    }
  95.  user_access_level: word;
  96.  numlines: byte;                    {from .CTL file: number of lines/screen  }
  97.  oldtextmode: word;                 {original text mode                      }
  98.  GoRip      : byte;                 { enables force RIP }
  99.  lastsetfore: byte;                 {last set_foreground color               }
  100.  setforecheck: boolean;             {check repetetive set_foreground calls?  }
  101.  dropfilepath: string;              {from parm list                          }
  102.  
  103.  soutput: text;                     {Simultanious output file                }
  104.  
  105.  proc_call_ptr: pointer;            {used internally                         }
  106.  nodirect: boolean;
  107.  lockbaud: longint;                 {lock baud rate                          }
  108.  com1,com2,com3,com4 : byte;        { temporary non-std comports             }
  109.  port1,port2,port3,port4:word;
  110.  irq1,irq2,irq3,irq4 : byte;
  111.  
  112. Procedure DV_Aware_On;
  113. Procedure DV_Pause;
  114. Procedure Win_Pause;
  115. procedure close_async_port;
  116. procedure open_async_port;
  117. function  skeypressed: boolean;
  118. procedure sendtext(s: string);
  119. procedure sgoto_xy(x,y: integer);
  120. procedure sclrscr;
  121. procedure sclreol;
  122. procedure swrite(s: string);
  123. procedure swritec(ch: char);
  124. procedure swriteln(s: string);
  125. procedure sread_char(var ch: char);
  126. procedure sread(var s: string);
  127. procedure sread_num(var n: integer);
  128. procedure sread_num_byte(var b: byte);
  129. procedure sread_num_longint(var n: longint);
  130. {Procedure speedread(var ch : char); }
  131. function time_left: integer;
  132. procedure set_foreground(f: byte);
  133. procedure set_background(b: byte);
  134. procedure set_color(f,b: byte);
  135. procedure prompt(var s: string; le: integer; pc: boolean);
  136. Procedure elapsed(time1_hour, time1_min, time1_sec, time2_hour, time2_min,
  137.                   time2_sec: longint; var elap_hour, elap_min, elap_sec: word);
  138. procedure get_stacked(var s: string);
  139. procedure sread_char_filtered(var ch: char);
  140. procedure display_status;
  141. procedure DDAssignSoutput(var f: text);
  142. procedure InitDoorDriver(ConfigFileName: string);
  143. function Time_used: integer;
  144.  
  145. Implementation
  146. {$L DVAWARE.OBJ}
  147.  
  148. Procedure DV_Aware_On;       External;
  149. Procedure DV_Pause;          External;
  150.  
  151. var
  152.  buffered: boolean;
  153.  exitsave: pointer;
  154.  tcolor,bcolor: integer;
  155.  firsttime: boolean;
  156.  
  157. { This releases the virtual machine time slice for MSwindows, Dos 5.0, OS/2 }
  158. procedure Win_Pause;
  159. const
  160.   Win_Irpt = $2F;
  161. var
  162.  Regs : Registers;
  163. begin
  164.  with Regs do
  165.  begin
  166.    Ax := $1680;
  167.    Intr(Win_Irpt,Regs);
  168.  end;
  169. end;
  170.  
  171. procedure textcolor(i: byte);
  172. begin;
  173.  if localcol then crt.textcolor(i);
  174.  tcolor:=i;
  175. end;
  176.  
  177. procedure textbackground(i: byte);
  178. begin;
  179.  if localcol then crt.textbackground(i);
  180.  bcolor:=i;
  181. end;
  182.  
  183. procedure elapsed(time1_hour, time1_min, time1_sec, time2_hour, time2_min,
  184.                   time2_sec: longint; var elap_hour, elap_min, elap_sec: word);
  185. var
  186.  a,b,c: longint;
  187. begin;
  188.  if time1_hour<time2_hour then time1_hour:=time1_hour+24;
  189.  a:=(time1_hour*3600)+(time1_min*60)+time1_sec;
  190.  b:=(time2_hour*3600)+(time2_min*60)+time2_sec;
  191.  c:=a-b;
  192.  if c>=3600 then elap_hour:=c div 3600 else elap_hour:=0;
  193.  c:=c-((c div 3600)*3600);
  194.  if c>=60 then elap_min:=c div 60 else elap_min:=0;
  195.  c:=c-((c div 60)*60);
  196.  elap_sec:=c;
  197. end;
  198.  
  199. function time_left: integer;
  200. var
  201.  hour, minute, second, sec100: word;
  202.  el_hr, el_mn, el_sc: word;
  203. begin;
  204.  gettime(hour, minute, second, sec100);
  205.  elapsed(hour, minute, second, st_hr, st_mn, st_sc, el_hr, el_mn, el_sc);
  206.  time_left:=time_credit+(bbs_time_left-((el_hr*60)+el_mn));
  207. end;
  208.  
  209. function time_used: integer;
  210. var
  211.  hour, minute, second, sec100: word;
  212.  el_hr, el_mn, el_sc: word;
  213. begin;
  214.  gettime(hour, minute, second, sec100);
  215.  elapsed(hour, minute, second, st_hr, st_mn, st_sc, el_hr, el_mn, el_sc);
  216.  time_used:=(el_hr*60)+el_mn;
  217. end;
  218.  
  219. procedure display_status;
  220. var
  221.  a,b: integer;
  222.  c,d: word;
  223.  x,y: integer;
  224.  hour, minute, second, sec100, el_mn, el_hr, el_sc: word;
  225. begin;
  226.  x:=wherex;
  227.  y:=wherey;
  228.  cursoroff;
  229.  window(1,1,80,numlines);
  230.  a:=tcolor;
  231.  b:=bcolor;
  232.  textcolor(statfore);
  233.  textbackground(statback);
  234.  if firsttime then begin;
  235.   gotoxy(1,numlines);
  236.   clreol;
  237.   write(user_first_name+' '+user_last_name);
  238.   gotoxy(40-(length(progname+' - Node '+va(node_num)) div 2),numlines);
  239.   write(progname+' - Node '+va(node_num));
  240.   firsttime:=false;
  241.  end;
  242.  gettime(hour,minute,second,sec100);
  243.  elapsed(hour,minute,second,st_hr,st_mn,st_sc,el_hr,el_mn,el_sc);
  244.  c:=(bbs_time_left-1)+time_credit;
  245.  c:=c-((el_hr*60)+el_mn);
  246.  d:=60-el_sc;
  247.  gotoxy(70,numlines);
  248.  write(c,':',d,'   ');
  249.  if (time_left<mintime) and (time_check) then begin;
  250.   cursoron;
  251.   if notime<>'' then swriteln('(*** Time limit exceeded ***)');
  252.   swriteln('');
  253.   halt;
  254.  end;
  255.  textcolor(a);
  256.  textbackground(b);
  257.  window(1,1,80,numlines-1);
  258.  gotoxy(x,y);
  259.  cursoron;
  260. end;
  261.  
  262. procedure SendText(s: string);
  263. var
  264.  a: integer;
  265. begin;
  266.  for a:=1 to length(s) do AsyncSendChar(s[a]);
  267. end;
  268.  
  269. procedure CharOut(ch: char);
  270. begin;
  271.  AsyncSendChar(ch);
  272. end;
  273.  
  274. function charin(var ch: char): boolean;
  275. begin;
  276.  if badchar<>'' then
  277.    begin;
  278.      ch:=badchar[1];
  279.      delete(badchar,1,1);
  280.      charin:=true;
  281.    end
  282.  else
  283.   if AsyncCharPresent then
  284.      begin;
  285.        AsyncReceiveChar(ch);
  286.        charin:=true;
  287.      end
  288.  else charin:=false;
  289. end;
  290.  
  291. procedure Done;
  292. begin;
  293.   if buffered then
  294.      AsyncFlushOutput;
  295.   If Not X00ExtOK then
  296.      AsyncCloseCom(com_port);
  297.   buffered := false;
  298. end;
  299.  
  300. procedure sclrscr;
  301. begin;
  302. { if not local then CharOut(#12); }
  303.  if not local then sendtext(#27'[2J');
  304.  clrscr;
  305.  curlinenum:=1;
  306.  lastsetfore:=99;
  307. end;
  308.  
  309. procedure sclreol;
  310. begin;
  311.  if not local then sendtext(#27'[K');
  312.  clreol;
  313. end;
  314.  
  315. procedure swritec(ch: char);
  316. begin;
  317.  if not local then
  318.    AsyncSendChar(ch);
  319.  if ansion then
  320.     begin
  321.       ansi_write(ch);
  322.     end
  323.  else
  324.     write(ch);
  325. end;
  326.  
  327. procedure swrite(s: string);
  328. var
  329.  a: integer;
  330.  s2: string;
  331. begin;
  332.  if hexon then hexfilt(s);
  333.  if not local then sendtext(s);
  334.  if ansion then begin;
  335.   ansi_write_str(s);
  336.  end else write(s);
  337. end;
  338.  
  339. procedure swriteln(s: string);
  340. var
  341.  a: integer;
  342.  s2: string;
  343. begin;
  344.  if hexon then hexfilt(s);
  345.  if not local then sendtext(s+#13+#10);
  346.  if ansion then begin;
  347.   s:=s+#13+#10;
  348.   ansi_write_str(s);
  349.  end else writeln(s);
  350.  
  351. end;
  352.  
  353. procedure myexit;
  354. begin;
  355.  If not local then done;
  356.  if lastmode<>oldtextmode then textmode(oldtextmode);
  357.  cursoron;
  358.  { This should fix the problem OS/2 serial IO drivers are having exiting. }
  359.  exitproc:=exitsave;
  360. end;
  361.  
  362. Procedure CallProc;
  363. inline($FF/$1E/Proc_Call_Ptr);
  364.  
  365. procedure sread_ch(var c: char);
  366. var
  367.  a: char;
  368.  i,cc: integer;
  369. begin;
  370.  cc:=0;
  371.  a:=chr(0);
  372.  charorigin:=localchar;
  373.  repeat;
  374.   if not local then if not AsyncCarrierPresent then begin;
  375.    writeln;
  376.    writeln('Carrier Dropped, returning to BBS.');
  377.    cdropped:=true;
  378.    halt;
  379.   end;
  380.   if not local then if charin(a) then charorigin:=remotechar;
  381.   if keypressed then
  382.     begin;
  383.        a:=readkey;
  384.        if (a=#0) and (keypressed) then
  385.         begin;
  386.           a:=readkey;
  387.         end;
  388.      end;
  389.  
  390.   If a = chr(0) then
  391.     If cc mod 100 = 99 then
  392.       begin
  393.         If DVOK then
  394.           DV_Pause
  395.         else
  396.         If Os2OK or WinOK then
  397.           Win_Pause;
  398.       end;
  399.  
  400.   if statline then
  401.     begin;
  402.       inc(cc);
  403.       if cc=1 then display_status;
  404.       if cc=1000 then cc:=0;
  405.     end;
  406.  until a<>chr(0);
  407.  c:=a;
  408. end;
  409.  
  410. procedure sread_char(var ch: char);
  411. var
  412.  ch1,ch2: char;
  413. begin;
  414.  curlinenum:=1;
  415.  repeat;
  416.   if macro<>'' then
  417.     begin;
  418.       ch:=macro[1];
  419.       delete(macro,1,1);
  420.     end
  421.   else
  422.     repeat;
  423.     ch:=#0;
  424.     if fouled_up<>#0 then
  425.       begin;
  426.         ch:=fouled_up;
  427.         fouled_up:=#0;
  428.       end
  429.     else
  430.       begin;
  431.         sread_ch(ch1);
  432.         if ch1=^N then
  433.           begin;
  434.             ch1:=#1;
  435.             macro:=macro_str;
  436.           end;
  437.         delay(20);
  438.         if (ch1=#27) and skeypressed then
  439.           begin;
  440.             sread_ch(ch2);
  441.             if ch2='[' then
  442.               begin;
  443.                 sread_ch(ch2);
  444.                 if (ch2 in ['1'..'9']) and (skeypressed) then
  445.                   sread_ch(ch2);
  446.                 case ch2 of
  447.                    'A' : ch:=^E;
  448.                    'B' : ch:=^X;
  449.                    'C' : ch:=^D;
  450.                    'D' : ch:=^S;
  451.                 end;
  452.               end
  453.             else
  454.               begin;
  455.                 ch:=ch1;
  456.                 fouled_up:=ch2;
  457.               end;
  458.            end
  459.          else
  460.            ch:=ch1;
  461.         end;
  462.   until ch<>#0;
  463.  until ch<>#1;
  464. end;
  465.  
  466. procedure sread_char_filtered(var ch: char);
  467. begin;
  468.  sread_char(ch);
  469.  if ch in [#1..#7,#10..#12,#14..#31,#127..#255] then ch:='.';
  470. end;
  471.  
  472. procedure get_stacked(var s: string);
  473. var
  474.  s2: string;
  475.  a: integer;
  476.  b: boolean;
  477. begin;
  478.  s:='';
  479.  s2:='';
  480.  b:=false;
  481.  if length(stacked)=0 then begin;
  482.   s:='';
  483.   exit;
  484.  end;
  485.  for a:=1 to length(stacked) do begin;
  486.   if stacked[a]=';' then b:=true else if not b then s:=s+stacked[a];
  487.   if b then s2:=s2+stacked[a];
  488.  end;
  489.  if length(s2)>=1 then delete(s2,1,1);
  490.  stacked:=s2;
  491. end;
  492.  
  493. procedure sread(var s: string);
  494. var
  495.  ch: char;
  496.  hexsave: boolean;
  497. begin;
  498.  hexsave:=hexon;
  499.  hexon:=false;
  500.  curlinenum:=1;
  501.  s:='';
  502.  get_stacked(s);
  503.  if s<>'' then swrite(s) else begin;
  504.   repeat;
  505.    sread_char_filtered(ch);
  506.    if (ch<>#8) and (ch<>^M) then begin;
  507.     s:=s+ch;
  508.     swrite(ch);
  509.    end;
  510.    if (ch=chr(8)) and (length(s)>0) then begin;
  511.     delete(s,length(s),1);
  512.     swrite(chr(8)+' '+chr(8));
  513.    end;
  514.   until (ch=^M);
  515.   if (pos(';',s)<>0) and (stackon) then begin;
  516.    stacked:=s;
  517.    get_stacked(s);
  518.   end;
  519.  end;
  520.  swriteln('');
  521.  hexon:=hexsave;
  522.  if hexon then hextodec(s);
  523. end;
  524.  
  525. procedure sread_num(var n: integer);
  526. var
  527.  x,y,code: integer;
  528.  s: string;
  529.  ch: char;
  530. begin;
  531.  sread(s);
  532.  val(s,n,x);
  533. end;
  534.  
  535. procedure sread_num_byte(var b: byte);
  536. var
  537.  x,y,code: integer;
  538.  s: string;
  539.  ch: char;
  540. begin;
  541.  sread(s);
  542.  val(s,b,x);
  543. end;
  544.  
  545. procedure sread_num_longint(var n: longint);
  546. var
  547.  x,y,code: integer;
  548.  s: string;
  549.  ch: char;
  550. begin;
  551.  sread(s);
  552.  val(s,n,x);
  553. end;
  554. {
  555. Procedure SpeedRead(var ch : char);
  556. var
  557.   a : char;
  558. begin
  559.  
  560.   ch := chr(0);
  561.   a := chr(0);
  562.   If local then
  563.     begin
  564.       If KeyPressed then
  565.          a :=readkey;
  566.       If a <> chr(0) then
  567.          ch := a
  568.       else
  569.       If DVOK then
  570.          DV_Pause
  571.       else
  572.       If Os2OK or WinOK then
  573.          Win_Pause;
  574.       exit;
  575.     end;
  576.  
  577.   charorigin:=localchar;
  578.   If (Not AsyncCarrierPresent) then begin
  579.       writeln;
  580.       writeln('Carrier Dropped, returning to BBS.');
  581.       cdropped:=true;
  582.       halt;
  583.     end;
  584.  
  585.   if charin(a) then
  586.     charorigin:=remotechar;
  587.  
  588.   if (a<>chr(0)) then
  589.     ch := a
  590.   else
  591.   If DVOK then
  592.     DV_Pause
  593.   else
  594.   If Os2OK or WinOK then
  595.     Win_Pause;
  596. end;
  597. }
  598.  
  599. function va(i: integer): string;
  600. var
  601.  s: string;
  602. begin;
  603.  str(i,s);
  604.  va:=s;
  605. end;
  606.  
  607. procedure set_foreground;  { f : byte }
  608. const
  609.   colorf: array[0..7] of integer = (30,34,32,36,31,35,33,37);
  610.   colorb: array[0..7] of integer = (40,44,42,46,41,45,43,47);
  611. var
  612.  s,sb : string;
  613. begin;
  614.  if f > 31 then exit;
  615.  if (f = current_foreground) then exit;
  616.  textcolor(f);
  617.  if not local then
  618.    begin
  619.    if (f=7) and (current_background=0) then
  620.        sendtext(#27+'[0m')
  621.    else
  622.    begin
  623.    If current_background = 0 then
  624.      sb := ''
  625.    else
  626.      sb := ';'+va(colorb[current_background]);
  627.    case f of
  628.      0..7  :  begin
  629.                 s := va(colorf[f]);
  630.                 case current_foreground of
  631.                 { 0..7  : s := s;  }
  632.                   8..31 : s := '0;'+s+sb;
  633.                end;
  634.             end;
  635.      8..15 : begin
  636.                s := va(colorf[f-8]);
  637.                case current_foreground of
  638.                   0..7  : s := '1;'+s;
  639.               {   8..15 : s := s; }
  640.                  16..31 : s := '0;1;'+s+sb;
  641.                end;
  642.              end;
  643.     16..23 : begin
  644.                s := va(colorf[f-16]);
  645.                case current_foreground of
  646.                   0..7  : s := '5;'+s;
  647.                   8..15,
  648.                { 16..23 : s := s; }
  649.                  24..31 : s := '0;5;'+s+sb;
  650.                end;
  651.             end;
  652.     24..31 : begin
  653.                s := va(colorf[f-24]);
  654.                 case current_foreground of
  655.                   0..7  : s := '1;5;'+s;
  656.                   8..15 : s := '5;'+s;
  657.                  16..23 : s := '1;'+s;
  658.               {  24..31 : s := s; }
  659.                 end;
  660.             end;
  661.      end;
  662.        sendtext(#27+'['+s+'m');
  663.     end;
  664.   end;
  665.   current_foreground:=f;
  666. end;
  667.  
  668. procedure set_background;  { b : byte }
  669. const
  670.  colorb: array[0..7] of integer = (40,44,42,46,41,45,43,47);
  671. begin;
  672.  if b > 7 then exit;
  673.  if (b = current_background) then exit;
  674.  textbackground(b);
  675.  current_background:=b;
  676.  if not local then
  677.     if (current_foreground=7) and (b=0) then
  678.        sendtext(#27+'[0m')
  679.     else
  680.        sendtext(#27+'['+va(colorb[b])+'m');
  681. end;
  682.  
  683. Procedure Set_Color;     { f,b : byte }
  684. const
  685.   colorf: array[0..7] of integer = (30,34,32,36,31,35,33,37);
  686.   colorb: array[0..7] of integer = (40,44,42,46,41,45,43,47);
  687. var
  688.  f1:byte;
  689.  s:string;
  690.  NoBackG_Ok : boolean;
  691. begin
  692.  if (f>31) or (b>7) then exit;
  693.  if (f=current_foreground) and (b=current_background) then exit;
  694.  if (f<>current_foreground) and (b<>current_background) then
  695.     begin
  696.       textcolor(f);
  697.       textbackground(b);
  698.       If not local then
  699.          If (f=7) and (b=0) then
  700.             sendtext(#27+'[0m')
  701.          else
  702.          begin
  703.           s := '[';
  704.           NoBackG_OK := false;
  705.           case f of
  706.             0..7  : begin
  707.                       f1:=f;
  708.                       case current_foreground of
  709.                       { 0..7  : s := s;  }
  710.                         8..31 : begin
  711.                                   s := s+'0;';
  712.                                   NoBackG_OK := true;
  713.                                 end;
  714.                       end;
  715.                     end;
  716.             8..15 : begin
  717.                       f1:=f-8;
  718.                       case current_foreground of
  719.                         0..7  : s := s+'1;';
  720.                     {   8..15 : s := s; }
  721.                        16..31 : begin
  722.                                   s := s+'0;1;';
  723.                                   NoBackG_OK := true;
  724.                                 end;
  725.                       end;
  726.                     end;
  727.            16..23 : begin
  728.                       f1:=f-16;
  729.                       case current_foreground of
  730.                         0..7  : s := s+'5;';
  731.                         8..15,
  732.                      { 16..23 : s := s; }
  733.                        24..31 : begin
  734.                                   s := s+'0;5;';
  735.                                   NoBackG_OK := true;
  736.                                 end;
  737.                      end;
  738.                    end;
  739.           24..31 : begin
  740.                      f1:=f-24;
  741.                      case current_foreground of
  742.                         0..7  : s := s+'1;5;';
  743.                         8..15 : s := s+'5;';
  744.                        16..23 : s := s+'1;';
  745.                     {  24..31 : s := s; }
  746.                      end;
  747.                    end;
  748.          end;
  749.          If NoBackG_OK and (b=0) then
  750.            sendtext(#27+s+va(colorf[f1])+'m')
  751.          else
  752.            sendtext(#27+s+va(colorf[f1])+';'+va(colorb[b])+'m');
  753.       end;
  754.       current_foreground:=f;
  755.       current_background:=b;
  756.     end
  757.      else
  758.      if (f<>current_foreground) then
  759.         set_foreground(f)
  760.      else
  761.        set_background(b);
  762. end;
  763.  
  764. procedure prompt;
  765. const
  766.  promptcol1=7;
  767.  promptcol2=1;
  768.  promptcol3=15;
  769. var
  770.  fg,bg: integer;
  771.  x,y,code: integer;
  772.  ch: char;
  773.  a: integer;
  774.  hexsave: boolean;
  775. begin;
  776.  hexsave:=hexon;
  777.  hexon:=false;
  778.  fg:=current_foreground;
  779.  bg:=current_background;
  780.  get_stacked(s);
  781.  if s<>'' then begin;
  782.   set_foreground(promptcol3);
  783.   while length(s)>le do delete(s,length(s),1);
  784.   swrite(s);
  785.   set_foreground(fg);
  786.  end else begin;
  787.   if not color_chg then pc:=false;
  788.   if pc then begin;
  789.    set_foreground(promptcol1);
  790.    set_background(promptcol2);
  791.    for a:=1 to le do swrite(' ');
  792.    for a:=1 to le do swrite(#8);
  793.    x:=wherex;
  794.    y:=wherey;
  795.   end;
  796.   s:='';
  797.   repeat;
  798.    sread_char_filtered(ch);                                 { read(kbd,ch);}
  799.    if (ch<>#8) and (ch<>^M) and (length(s)<le) then begin;
  800.     s:=s+ch;
  801.     swrite(ch);                                    { write(ch);}
  802.    end;
  803.    if length(s)>200 then delete(s,1,1);
  804.    if (ch=chr(8)) and (length(s)>0) then begin;
  805.     delete(s,length(s),1);
  806.     swrite(chr(8));                                { write(#8,' ',#8);}
  807.     swrite(' ');
  808.     swrite(#8);
  809.    end;
  810.   until (ch=^M) or (length(s)=999);
  811.   if pc then begin;
  812.    set_foreground(promptcol3);
  813.    set_background(bg);
  814.    while wherex>x do swrite(#8);
  815.    swrite(s);                                      { write(s);}
  816.    while wherex<x+le do swrite(' ');               { write(' ');}
  817.    set_foreground(fg);
  818.   end;
  819.   swriteln('');                                    { writeln('');}
  820.   if pos(';',s)<>0 then begin;
  821.    stacked:=s;
  822.    get_stacked(s);
  823.    while length(s)>le do delete(s,length(s),1);
  824.   end;
  825.  end;
  826.  hexon:=hexsave;
  827. end;
  828.  
  829. procedure sgoto_xy;
  830. var
  831.  s,s2: string;
  832. begin;
  833.  gotoxy(x,y);
  834.  curlinenum := y;
  835.  s:=#27+'[';
  836.  str(y,s2);
  837.  s:=s+s2;
  838.  str(x,s2);
  839.  s:=s+';'+s2+'f';
  840.  if not local then sendtext(s);
  841. end;
  842.  
  843. function skeypressed: boolean;
  844. var
  845.  b: boolean;
  846. begin;
  847.  b:=false;
  848.  if not local then b:=AsyncCharPresent;
  849.  if not b then b:=keypressed;
  850.  if macro<>'' then b:=true;
  851.  skeypressed:=b;
  852. end;
  853.  
  854. procedure close_async_port;
  855. begin;
  856.  if buffered then begin;
  857.    buffered:=false;
  858.    AsyncFlushOutput;
  859.    AsyncCloseUp;
  860.  end;
  861. end;
  862.  
  863. procedure open_async_port;
  864. begin;
  865.  AsyncSelectPort(com_port);
  866.  if lockbaud=0 then
  867.   AsyncSetBaud(baud_rate)
  868.  else
  869.   AsyncSetBaud(lockbaud);
  870.  buffered := true;   { Not set in original DD - this may not be the best }
  871.                      { place for this but it does work in my tests       }
  872. end;
  873. {
  874.   }
  875. var
  876.  nclastchar: char;
  877.  
  878. function NewCrtOutPut(var f: textrec): integer;
  879. var
  880.  p: integer;
  881. begin;
  882.  for p:=0 to f.bufpos-1 do swrite(f.bufptr^[p]);
  883.  f.bufpos:=0;
  884.  NewCrtOutPut:=0;
  885. end;
  886.  
  887. function NewCrtInPut(var f: textrec): integer;
  888. var
  889.  p: integer;
  890.  ch: char;
  891. begin;
  892.  with f do begin;
  893.   p:=0;
  894.   if nclastchar=#13 then begin; nclastchar:=' '; end else repeat;
  895.    ch:=readkey;
  896.    nclastchar:=ch;
  897.    write(ch);
  898.    bufptr^[p]:=ch;
  899.    inc(p);
  900.    if ch=#13 then write(#10);
  901.    if ch=#8 then begin;
  902.     write(' '#8);
  903.     if p>0 then dec(p);
  904.     if p>0 then dec(p);
  905.    end;
  906.   until (p=bufsize-1) or (ch=#13);
  907.   bufpos:=0;
  908.   bufend:=p;
  909.  end;
  910.  NewCrtInput:=0;
  911. end;
  912.  
  913. function NewCrtIgnore(var f: textrec): integer;
  914. begin;
  915.  newcrtignore:=0;
  916. end;
  917.  
  918. function NewCRTOpen(var f: textrec): integer;
  919. begin;
  920.  if f.mode=fmInput then begin;
  921.   f.inoutfunc:=@NewCrtInput;
  922.   f.flushfunc:=@NewCrtIgnore;
  923.  end else begin;
  924.   f.mode:=fmOutput;
  925.   f.inoutfunc:=@NewCrtOutPut;
  926.   f.flushfunc:=@NewCrtOutPut;
  927.  end;
  928.  NewCrtOpen:=0;
  929. end;
  930.  
  931. Function RipDetect: boolean;
  932. var
  933.   i,j,k : integer;
  934.   a : char;
  935.   s : string;
  936.   RipYes : boolean;
  937. begin
  938.  RipYes := false;
  939.  If local then
  940.    begin
  941.      RipDetect := RipYes;
  942.      exit;
  943.    end;
  944.  
  945.  sendtext(#27+'[0;30m'+#13+#10);
  946.  writeln;
  947.  writeln('Checking for RIP');
  948.  sendtext(#27'[!');
  949.  delay(222);
  950.  s := '';
  951.  i := 0;
  952.  j := 0;
  953.  charorigin:=localchar;
  954.  repeat;
  955.  
  956.    a:=chr(0);
  957.    inc(i);
  958.  
  959.    If Not AsyncCarrierPresent then
  960.      begin
  961.         writeln;
  962.         writeln('Carrier Dropped or Comport not opened.');
  963.         writeln('Returning to BBS.');
  964.         cdropped:=true;
  965.         halt;
  966.      end;
  967.  
  968.   if charin(a) then
  969.     charorigin:=remotechar;
  970.   if (a<>chr(0)) then
  971.     begin
  972.       s := s+a;
  973.       inc(j);
  974.     end
  975.   else
  976.      begin
  977.        If (i mod 50 = 0) then
  978.          begin
  979.            If DVOK then
  980.              DV_Pause
  981.            else
  982.              If Os2OK or WinOK then
  983.              Win_Pause;
  984.          end;
  985.      end;
  986.   delay(2);
  987.   until (i>666) or (j>13);
  988.  
  989.   If Copy(s,1,3) = 'RIP' then
  990.     begin
  991.       RipYes := true;
  992.       writeln('Rip Detected');
  993.       if charin(a) then
  994.          charorigin:=remotechar;
  995.     end;
  996.  RipDetect := RipYes;
  997.  Swriteln('');
  998. end;
  999.  
  1000. procedure DDAssignSOutput(var f: text);
  1001. begin;
  1002.  with textrec(f) do begin;
  1003.   handle   := $FFFF;
  1004.   mode     := fmclosed;
  1005.   bufsize  := sizeof(buffer);
  1006.   bufptr   := @buffer;
  1007.   OpenFunc := @NewCrtOpen;
  1008.   CloseFunc:= @NewCrtIgnore;
  1009.   Name[0]  := #0;
  1010.  end;
  1011. end;
  1012.  
  1013. procedure InitDoorDriver(ConfigFileName: string);
  1014. Var
  1015.  i,a: byte;
  1016.  b: integer;
  1017.  junk: word;
  1018.  
  1019. begin;
  1020.  initddansi;
  1021.  oldtextmode:=lastmode;
  1022.  lastsetfore:=99;
  1023.  setforecheck:=false;
  1024.  badchar:='';
  1025.  ansion:=false;
  1026.  numlines:=25;
  1027.  clrscr;
  1028.  window(1,1,80,numlines-1);
  1029.  node_num:=1;
  1030.  statfore:=7;
  1031.  statback:=1;
  1032.  GoRip := 0;
  1033.  com_port:=0;
  1034.  fouled_up:=#0;
  1035.  stacked:='';
  1036.  hexon:=false;
  1037.  buffered:=false;
  1038.  cdropped:=false;
  1039.  exitsave:=exitproc;
  1040.  exitproc:=@myexit;
  1041.  firsttime:=true;
  1042.  
  1043.  LoadPorts(port1,port2,port3,port4,irq1,irq2,irq3,irq4);
  1044.  Loadconfig( ConfigFileName,
  1045.              bbs_software,
  1046.              user_first_name,user_last_name,
  1047.              user_access_level,
  1048.              bbs_time_left,
  1049.              com_port,
  1050.              baud_rate,
  1051.              node_num,
  1052.              local,
  1053.              graphics,
  1054.              color1,
  1055.              color_chg,
  1056.              x00extok,
  1057.              board_name,
  1058.              pause_code,
  1059.              sysop_first_name,
  1060.              sysop_last_name,
  1061.              maxtime,
  1062.              localcol,
  1063.              statfore,
  1064.              statback,
  1065.              statline,
  1066.              ESMOK,
  1067.              fossilio,
  1068.              dropfilepath,
  1069.              GoRip,
  1070.              lockbaud,
  1071.              nodirect,
  1072.              port1,port2,port3,port4,irq1,irq2,irq3,irq4);
  1073.  
  1074.  numlines:=25;
  1075.  if nodirect then directvideo:=false;
  1076.  clrscr;
  1077.  window(1,1,80,numlines-1);
  1078.  textcolor(7);
  1079.  textbackground(0);
  1080.  default_fore:=7;
  1081.  default_back:=0;
  1082.  gettime(st_hr,st_mn,st_sc,junk);
  1083.  
  1084.  GetBBSInfo( bbs_software,
  1085.              user_first_name,user_last_name,
  1086.              user_access_level,
  1087.              bbs_time_left,
  1088.              com_port,
  1089.              baud_rate,
  1090.              node_num,
  1091.              local,
  1092.              graphics,
  1093.              color1,
  1094.              color_chg,
  1095.              board_name,
  1096.              sysop_first_name,
  1097.              sysop_last_name,
  1098.              maxtime,
  1099.              dropfilepath,
  1100.              lockbaud);
  1101.  
  1102.  ReSetPorts(port1,port2,port3,port4,irq1,irq2,irq3,irq4);
  1103.  if not local then
  1104.    begin;
  1105.     if FossilIO then AsyncSelectFossil else
  1106.       AsyncSelectInternal;
  1107.     Open_Async_Port;
  1108.    end;
  1109.  
  1110.  if fossilio and (initok=false) and (not local) then begin;
  1111.   writeln('');
  1112.   writeln('Fossil was not initialized properly! You should change to INTERNAL');
  1113.   writeln('communications routines.');
  1114.   delay(1500);
  1115.  end;
  1116.  
  1117.  If GoRip = 4 then
  1118.      graphics := 5;
  1119.  If Graphics <> 5 then
  1120.     If RipDetect then
  1121.           graphics := 5;
  1122.  
  1123.  DV_Aware_ON;
  1124.  current_foreground:=default_fore;
  1125.  current_background:=default_back;
  1126.  if graphics = 3 then
  1127.    begin
  1128.      set_foreground(statfore);
  1129.      set_background(statback);
  1130.    end;
  1131.  curlinenum:=1;
  1132.  time_check:=true;
  1133.  time_credit:=0;
  1134.  macro_str:='';
  1135.  macro:='';
  1136.  mintime:=1;
  1137.  notime:='';
  1138.  user_first_name:=stu(user_first_name);
  1139.  user_last_name:=stu(user_last_name);
  1140.  stackon:=true;
  1141.  if node_num=0 then node_num:=1;
  1142.  ddassignsoutput(soutput);
  1143.  rewrite(soutput);
  1144.  
  1145. end;
  1146.  
  1147. end.
  1148.  
  1149.